home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / alt-menu.l next >
Encoding:
Text File  |  1989-07-12  |  9.4 KB  |  270 lines
  1. ;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;; Most of this stuff is a direct copy from label and button
  20. ;; with virtual tacked on the front of the names.
  21.  
  22. ;;; Change History:
  23. ;;; ----------------------------------------------------------------------------
  24. ;;; ??/??/88   LGO   Created.
  25.  
  26.  
  27. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  28.  
  29.  
  30. (export '( virtual-label
  31.       virtual-button
  32.       ))
  33.  
  34. ;; When CLUE's CLOS gets multiple inheritance, replace all this with
  35. ;; (defcontact virtual-button (virtual button)
  36. ;;   ()
  37. ;;   )
  38.  
  39.  
  40. (defcontact virtual-label (virtual)
  41.   ((title :initform nil :type stringable) ;; Defaults to name string
  42.    (style :initform :normal :type (member :normal :box :reverse :box-reverse))
  43.    (justify :initform :center :type (member :left :center :right)
  44.         :accessor button-justify)
  45.    (font :type font)
  46.    (foreground :type pixel)
  47.    (background :type pixel)
  48.    (inside-border-width :initform 3 :type integer
  49.             :accessor inside-border-width)
  50.    )
  51.   (:resources
  52.     title
  53.     justify
  54.     (font :initform "fg-18")
  55.     foreground
  56.     background
  57.     inside-border-width)
  58.   (:documentation "One line string display in a single font with different styles and justification")
  59.   )
  60.  
  61. (define-resources
  62.   (* virtual-label foreground) 1   ;white
  63.   (* virtual-label background) 0   ;black
  64.   (* virtual-label border)     1   ;white
  65.   (* virtual-label border-width) 1
  66.   )
  67.  
  68. (defmethod initialize-instance :after ((self virtual-label) &rest init-plist)
  69.   (declare (ignore init-plist))
  70.   (with-slots (title font height width inside-border-width) self
  71.     (when (symbolp title) ;; NIL is a symbol
  72.       (setf title (string-capitalize (string (or title (contact-name self))))))
  73.     (let ((label-font font))
  74.       (setf height (+ (max-char-ascent label-font)
  75.                (max-char-descent label-font)
  76.                (* 2 inside-border-width)
  77.                2))
  78.       (setf width (+ 2 (text-width label-font title))))))
  79.  
  80. (defmethod display ((self virtual-label) &optional x y width height &key)
  81.   (declare (ignore x y width height))
  82.   (let ((win self))
  83.     (with-slots (font title justify inside-border-width style
  84.                (contact-height height) (contact-width width)
  85.                (label-foreground foreground) (label-background background)) self
  86.       (let* ((label-font font)
  87.          (descent (max-char-descent label-font))
  88.          (string title)
  89.          (x 0)
  90.          (y (+ descent (floor contact-height 2))))
  91.     (case justify
  92.       (:left nil)
  93.       (:center (setq x (floor (- contact-width (text-width label-font string)) 2)))
  94.       (:right (setq x (- contact-width (text-width label-font string)))))
  95.     (let ((fore label-foreground)
  96.           (back label-background)
  97.           (inside-border nil))
  98.       (when (member style '(:reverse :box-reverse))
  99.         (rotatef fore back))
  100.       (when (member style '(:box :box-reverse))
  101.         (setq inside-border inside-border-width))
  102.       (using-gcontext (gc :drawable (contact-root self) :foreground back)
  103.         (rectangle win gc 0 0 contact-width contact-height :fill))
  104.       (using-gcontext (gc :drawable (contact-root self)
  105.                   :font label-font
  106.                   :foreground fore
  107.                   :background back
  108.                   :line-width inside-border)
  109.         (when inside-border
  110.           (let ((half (floor inside-border 2)))
  111.         (rectangle win gc half half (- contact-width inside-border) (- contact-height inside-border))))
  112.         (glyphs win gc x y string)
  113.         ))))))
  114.  
  115.  
  116. ;;;-----------------------------------------------------------------------------
  117. ;;; VIRTUAL-BUTTON
  118.  
  119. (defcontact virtual-button (virtual-label)
  120.   ((command-key :initform nil :type (or null character))
  121.    (selected :initform nil :type boolean :accessor selected)
  122.    (highlighted :initform nil :type boolean :accessor highlighted)
  123.    (event-mask :initform '(:exposure :owner-grab-button))
  124.    )
  125.   (:resources
  126.     (action  :initform nil :type (or null symbol function list))
  127.     command-key)
  128.   )
  129.  
  130. (defmethod initialize-instance :after ((self virtual-button) &key action &allow-other-keys)
  131.   (with-slots (callbacks) self
  132.     (when action
  133.       (push (if (functionp action)
  134.         (list ':select (list action))
  135.           (cons ':select action))
  136.         callbacks))))
  137.  
  138. (define-resources
  139.   (* virtual-button foreground) 1    ;white
  140.   (* virtual-button background) 0    ;black
  141.   (* virtual-button border)     1    ;white
  142.   (* virtual-button border-width) 1
  143.   )
  144.  
  145. (defevent virtual-button :button-press (display :select :toggle))
  146. (defevent virtual-button :button-release notify (display :select nil))
  147. (defevent virtual-button :enter-notify (display :highlight t))
  148. (defevent virtual-button :leave-notify (display :highlight nil))
  149.  
  150. (defmethod action-display ((button virtual-button)
  151.                            &key (select :unspecified) (highlight :unspecified))
  152.   (with-slots (style selected highlighted) button
  153.     (case select                ;Set SELECTED
  154.       (:unspecified)
  155.       (:toggle (setf selected (not selected)))
  156.       (otherwise (setf selected select)))
  157.     (unless (eq highlight :unspecified)        ;Set HIGHLIGHTED
  158.       (setf highlighted highlight))
  159.     (let ((old-style style))
  160.       (setf style                ;Set STYLE
  161.         (if highlighted
  162.         (if selected
  163.             :box-reverse
  164.           :box)
  165.           (if selected
  166.           :reverse
  167.         :normal)))
  168.       (unless (eq style old-style)        ;Redisplay when changed
  169.     (display button)))))
  170.  
  171. (defmethod notify ((button virtual-button) &optional (callback :select))
  172.   (with-slots (selected) button
  173.     (with-event (x y)
  174.       (when (and selected
  175.          callback
  176.          (inside-contact-p button x y))
  177.     (apply-callback button callback)))))
  178.  
  179. (defmethod slide-right ((button virtual-button) &optional (callback :cascade))
  180.   (with-slots (width height selected) button
  181.     (with-event (x y)
  182.       (when (and selected
  183.          callback
  184.          (and (< 0 x)
  185.               (< 0 y height)))
  186.     (apply-callback button callback)))))
  187.  
  188. ;;-----------------------------------------------------------------------------
  189.  
  190. (defcontact virtual-menu (virtual-composite)
  191.   ((ordering :type (or (member :first :last) function)
  192.          :initform :last
  193.          :accessor menu-insert-ordering)
  194.    )
  195.   (:resources function args)
  196.   )
  197.  
  198. (define-resources
  199.   (* virtual-menu height) 10
  200.   (* virtual-menu width) 10
  201.   )
  202.  
  203. (defun virtual-menu-choose (parent alist &rest options)
  204.   "Display a menu on parent from alist.
  205.  Alist entries are (stringable . options) where options are keyword-value pairs:
  206.  :font font
  207.  :justify (member :left :center :right)
  208.  :select (or function list)"
  209.   (apply #'menu-choose parent alist :menu-type 'virtual-menu :item-type 'virtual-button options))
  210.  
  211. (defmethod add-child ((self virtual-menu) contact &key)
  212.   "Put CONTACT on its parent's list of managed contacts"
  213.   (with-slots ((manager-children children)
  214.            (manager-ordering ordering)) self
  215.     (let ((children manager-children)
  216.       (ordering manager-ordering))
  217.       (unless (member contact children)
  218.     (case ordering
  219.       (:first (push contact children))
  220.       (:last (setf children (nconc children (list contact))))
  221.       (otherwise
  222.        (if (null (funcall ordering contact (car ordering)))
  223.            (push contact children)
  224.          (do ((c children (cdr c)))
  225.          ((null (cdr c))
  226.           (setf (cdr c) (list contact)))
  227.            ;; Insert contact when ordering "lessp" predicate returns nil
  228.            (unless (funcall ordering contact (cadr c))
  229.          (setf (cdr c) (list* contact (cdr c)))
  230.          (return nil))))))
  231.     (setf manager-children children)))))
  232.  
  233. (defmethod manage-geometry ((parent virtual-menu) contact x1 y1 width1 height1 border-width1 &key)
  234.   ;; The default geometry manager just does whatever it's asked
  235.   ;; Returns the new x y width height border-width
  236.   (declare (values success-p x y width height border-width))
  237. ;  (declare (type contact contact)
  238. ;       (type (or null int16) x1 y1)
  239. ;       (type (or null card16) width1 height1 border-width1)
  240. ;       (values success-p x y width height border-width))
  241.   (let* ((previous (previous-sibling contact));; Find the contact BEFORE this one
  242.      (x 0)
  243.      (y 0)
  244.      (width (or width1 (contact-width contact)))
  245.      (height (or height1 (contact-height contact)))
  246.      (border-width 0)
  247.      (success t))
  248.     (declare (type (or null contact) previous)
  249.          (type (or null int16) x y)
  250.          (type (or null card16) width height border-width)
  251.          (type boolean success))
  252.     (when previous
  253.       (setq y (+ (contact-y previous) (contact-height previous))))
  254.     (when (> width (contact-width parent))
  255.       (change-geometry parent :width width :accept-p t)
  256.       (setq width (contact-width parent))
  257.       (dolist (child (composite-children parent))
  258.     (when (managed-p child)
  259.       (resize child width (contact-height child) (contact-border-width child)))))
  260.     (setq width (max width (contact-width parent)))
  261.     (when (> (+ y height) (contact-height parent))
  262.       (change-geometry parent :height (+ y height) :accept-p t))
  263.     (setq success (and (or (null x1) (= x x1))
  264.                (or (null y1) (= y y1))
  265.                (or (null width1) (= width width1))
  266.                (or (null height1) (= height height1))
  267.                (or (null border-width1) (= border-width border-width1))))
  268. ;;    (PV success x y width height border-width)
  269.     (values success x y width height border-width)))
  270.